home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / parser / pattern-parser.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  5.0 KB  |  223 lines  |  [TEXT/CCL2]
  1. ;;;  File: pattern-parser        Author: John
  2.  
  3. ;;; This parses the pattern syntax except for the parts which need to be
  4. ;;; resolved by precedence parsing.
  5.  
  6. ;;; This parses a list of alternating pats & conops.
  7.  
  8. (define (parse-pat)
  9.  (trace-parser pat
  10.    (let* ((ps (parse-pat/list))
  11.       (pat (if (null? (cdr ps)) (car ps) (make pp-pat-list (pats ps)))))
  12.      (token-case
  13.       (\:\: (let ((signature (parse-signature)))
  14.           (make dynamic-pat (pat pat) (sig signature))))
  15.       (else pat)))))
  16.  
  17. ;;; This parses a list of patterns with intervening conops and + patterns
  18.  
  19. (define (parse-pat/list)
  20.   (token-case
  21.     (con (let ((pcon (pcon->ast)))
  22.        (setf (pcon-pats pcon) (parse-apat-list))
  23.        (cons pcon (parse-pat/tail))))
  24.     (-n
  25.      (advance-token) ; past -
  26.      (token-case
  27.       (numeric (let ((val (literal->ast)))
  28.          (cons (make pp-pat-negated)
  29.                (cons (make const-pat (value val))
  30.                  (parse-pat/tail)))))
  31.       (else
  32.        (signal-missing-token "<number>" "negative literal pattern"))))
  33.     (var
  34.      (let ((var (var->ast)))
  35.        (token-case
  36.     (+k (cons (make var-pat (var var))
  37.           (parse-+k-pat)))
  38.     (@  (let ((pattern (parse-apat)))
  39.           (cons (make as-pat (var var) (pattern pattern))
  40.             (parse-pat/tail))))
  41.     (else (cons (make var-pat (var var)) (parse-pat/tail))))))
  42.     (_
  43.      (let ((pat (make wildcard-pat)))
  44.        (token-case
  45.     (+k (cons pat (parse-+k-pat)))
  46.     (else (cons pat (parse-pat/tail))))))
  47.     (else (let ((apat (parse-apat)))
  48.         (cons apat (parse-pat/tail))))))
  49.  
  50.  
  51. (define (parse-+k-pat)
  52.   (advance-token)  ; past +
  53.   (token-case
  54.    (k (let ((val (literal->ast)))
  55.     (cons (make pp-pat-plus)
  56.           (cons (make const-pat (value val))
  57.             (parse-pat/tail)))))
  58.    (else (signal-missing-token "<integer>" "successor pattern"))))
  59.  
  60. (define (parse-pat/tail)
  61.    (token-case
  62.      (conop
  63.       (let ((con (pconop->ast)))
  64.     (cons con (parse-pat/list))))
  65.      (else '())))
  66.  
  67. (define (parse-apat)
  68.  (trace-parser apat
  69.    (token-case
  70.      (var (let ((var (var->ast)))
  71.         (token-case
  72.          (@
  73.           (let ((pattern (parse-apat)))
  74.         (make as-pat (var var) (pattern pattern))))
  75.          (else (make var-pat (var var))))))
  76.      (con (pcon->ast))
  77.      (literal (let ((value (literal->ast)))
  78.         (make const-pat (value value))))
  79.      (_ (make wildcard-pat))
  80.      (\( (token-case
  81.            (\) (**pcon/def (core-symbol "UnitConstructor") '()))
  82.        (else
  83.         (let ((pat (parse-pat)))
  84.           (token-case
  85.         (\, (**pcon/tuple (cons pat (parse-pat-list '\)))))
  86.         (\) pat)
  87.         (else
  88.          (signal-missing-token "`)' or `,'" "pattern")))))))
  89.      (\[ (token-case
  90.       (\] (make list-pat (pats '())))
  91.       (else (make list-pat (pats (parse-pat-list '\]))))))
  92.      (\~ (let ((pattern (parse-apat)))
  93.        (make irr-pat (pattern pattern))))
  94.      (else
  95.       (signal-invalid-syntax "an apat")))))
  96.  
  97. (define (parse-pat-list term)  ;; , separated
  98.   (let ((pat (parse-pat)))
  99.     (token-case
  100.      (\, (cons pat (parse-pat-list term)))
  101.      ((unquote term) (list pat))
  102.      (else
  103.       (signal-missing-token
  104.         (if (eq? term '\)) "`)'" "`]'")
  105.     "pattern")))))
  106.  
  107. (define (parse-apat-list)  ;; space separated
  108.   (token-case
  109.     (apat-start
  110.      (let ((pat (parse-apat)))
  111.        (cons pat (parse-apat-list))))
  112.     (else
  113.      '())))
  114.  
  115. ;;; The following routine scans patterns without creating ast structure.
  116. ;;; They return #t or #f depending on whether a valid pattern was encountered.
  117. ;;; The leave the scanner pointing to the next token after the pattern.
  118.  
  119. (define (scan-pat)  ; same as parse-pat/list
  120.   (and
  121.    (token-case
  122.     (con (scan-con)
  123.      (scan-apat-list))
  124.     (-n (advance-token)
  125.     (token-case
  126.      (numeric (advance-token)
  127.           '#t)
  128.      (else '#f)))
  129.     (var (and (scan-var)
  130.           (token-case
  131.            (@ (scan-apat))
  132.            (+k (scan-+k))
  133.            (else '#t))))
  134.     (_ (scan-+k))
  135.     (else (scan-apat)))
  136.    (scan-pat/tail)))
  137.  
  138. (define (scan-pat/tail)
  139.   (token-case
  140.    (conop (and (scan-conop)
  141.            (scan-pat)))
  142.    (else '#t)))
  143.  
  144. (define (scan-apat)
  145.   (token-case
  146.    (var (scan-var)
  147.     (token-case
  148.      (@ (scan-apat))
  149.      (else '#t)))
  150.    (con (scan-con))
  151.    (literal (advance-token)
  152.         '#t)
  153.    (_ '#t)
  154.    (\( (token-case
  155.     (\) '#t)
  156.     (else
  157.      (and (scan-pat)
  158.           (token-case
  159.            (\, (scan-pat-list '\)))
  160.            (\) '#t)
  161.            (else '#f))))))
  162.    (\[ (token-case
  163.     (\] '#t)
  164.     (else (scan-pat-list '\]))))
  165.    (\~ (scan-apat))
  166.    (else '#f)))
  167.  
  168. (define (scan-pat-list term)
  169.   (and (scan-pat)
  170.        (token-case
  171.     (\, (scan-pat-list term))
  172.     ((unquote term) '#t)
  173.     (else '#f))))
  174.  
  175. (define (scan-apat-list)
  176.   (token-case
  177.    (apat-start
  178.     (and (scan-apat)
  179.      (scan-apat-list)))
  180.    (else '#t)))
  181.  
  182. (define (scan-var)
  183.   (token-case
  184.    (varid '#t)
  185.    (\( (token-case
  186.     (varsym
  187.      (token-case
  188.       (\) '#t)
  189.       (else '#f)))
  190.     (else '#f)))
  191.    (else '#f)))
  192.  
  193. (define (scan-con)
  194.   (token-case
  195.    (conid '#t)
  196.    (\( (token-case
  197.     (consym
  198.      (token-case
  199.       (\) '#t)
  200.       (else '#f)))
  201.     (else '#f)))
  202.    (else '#f)))
  203.  
  204. (define (scan-conop)
  205.   (token-case
  206.    (consym '#t)
  207.    (\` (token-case
  208.     (conid
  209.      (token-case
  210.       (\` '#t)
  211.       (else '#f)))
  212.     (else '#f)))
  213.    (else '#f)))
  214.  
  215. (define (scan-+k)
  216.   (token-case
  217.    (+k (advance-token)  ; past the +
  218.        (token-case
  219.     (integer '#t)
  220.     (else '#f)))
  221.    (else '#t)))
  222.  
  223.